home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / cps / branch.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  3.7 KB  |  116 lines
  1. structure Branch : sig val branch: CPS.function list -> CPS.function list end =
  2. struct open CPS Access
  3.  
  4. val infinity = 1000000000
  5.  
  6. fun minl l =
  7.  let fun f(i,nil) = i | f(i,j::rest) = if i<j then f(i,rest) else f(j,rest)
  8.   in f(infinity,l)
  9.  end
  10.  
  11. val opp = fn P.boxed => P.unboxed | P.unboxed => P.boxed 
  12.            | P.< => P.>= | P.>= => P.< | P.> => P.<= | P.<= => P.>
  13.            | P.lessu => P.gequ | P.gequ => P.lessu
  14.            | P.ieql => P.ineq | P.ineq => P.ieql 
  15.            | P.feql => P.fneq | P.fneq => P.feql 
  16.        | P.fge => P.flt | P.flt => P.fge 
  17.        | P.fle => P.fgt | P.fgt => P.fle
  18.            | _ => ErrorMsg.impossible "3893 in Branch"
  19.  
  20. fun minl l = let fun f(m,a::r) = if m<a then f(m,r) else f(a,r)
  21.                    | f(m,nil) = m
  22.               in f(infinity,l)
  23.              end
  24.  
  25. fun all (a::rest) = a andalso all rest | all nil = true
  26.  
  27. fun scc funs = 
  28. let exception Unseen
  29.     type info = {dfsnum: int ref, sccnum: int ref, body: cexp} 
  30.     val m : info Intmap.intmap = Intmap.new(32,Unseen)
  31.     val lookup = Intmap.map m
  32.  
  33.     val compmap : int Intmap.intmap = Intmap.new(32,Unseen)
  34.     
  35.     val comps = ref 0 and id = ref 0
  36.  
  37.     val stack : (int * int ref) list ref = ref nil
  38.  
  39.     fun scc (node, {dfsnum as ref d, sccnum, body}) =
  40.        if d >= 0 then d else
  41.         let fun g (RECORD(_,_,_,_,e)) = g e
  42.               | g (SELECT(_,_,_,e)) = g e
  43.               | g (OFFSET(_,_,_,e)) = g e
  44.               | g (SWITCH(_,_,el)) = minl (map g el)
  45.               | g (SETTER(_,_,e)) = g e
  46.               | g (LOOKER(_,_,_,e)) = g e
  47.               | g (ARITH(_,_,_,e)) = g e
  48.               | g (PURE(_,_,_,e)) = g e
  49.               | g (BRANCH(_,_,_,a,b)) = min(g a, g b)
  50.               | g (APP(LABEL w, _)) = scc(w, lookup w)
  51.               | g _ = infinity
  52.           
  53.             fun newcomp(c,(n,sccnum)::rest) = 
  54.             (sccnum := c;
  55. (*                         print n; print "  "; print c; print "\n"; *)
  56.                          if n=node then rest else newcomp(c,rest))
  57.  
  58.         val v = !id 
  59.             val _ = (id := v+1; 
  60.              stack := (node, sccnum) :: !stack;
  61.                      dfsnum := v)
  62.             val gb = g body
  63.         in if v <= gb
  64.              then (stack := newcomp(!comps before comps := !comps + 1, !stack);
  65.                    v)
  66.              else gb
  67.        end
  68.  in app (fn (f,_,body) => Intmap.add m 
  69.                      (f,{dfsnum=ref ~1, sccnum=ref ~1, body=body}))
  70.         funs;
  71.     app (fn (f,_,_) => scc(f, lookup f)) funs;
  72.     ! o #sccnum o lookup
  73. end
  74.  
  75. fun branch funs = 
  76. let val sccnum = scc funs
  77.     fun rewrite(f,vl,body) =
  78.         let val n = sccnum f
  79.             fun g (RECORD(k,r,w,e)) = 
  80.             let val (d,e') = g e in (d, RECORD(k,r,w, e')) end
  81.               | g (SELECT(i,v,w,e)) = 
  82.             let val (d,e') = g e in (d, SELECT(i,v,w, e')) end
  83.               | g (OFFSET(i,v,w,e)) =
  84.             let val (d,e') = g e in (d, OFFSET(i,v,w, e')) end
  85.               | g (SWITCH(v,c,el)) = 
  86.             let val ge = map g el
  87.                          in (all (map #1 ge), SWITCH(v, c, map #2 ge))
  88.                         end
  89.               | g (SETTER(p,vl,e)) = 
  90.             let val (d,e') = g e in (d, SETTER(p,vl,e')) end
  91.               | g (LOOKER(p,vl,w,e)) = 
  92.             let val (d,e') = g e in (d, LOOKER(p,vl,w,e')) end
  93.               | g (ARITH(p,vl,w,e)) = 
  94.             let val (d,e') = g e in (d, ARITH(p,vl,w,e')) end
  95.               | g (PURE(p,vl,w,e)) = 
  96.             let val (d,e') = g e in (d, PURE(p,vl,w,e')) end
  97.               | g (BRANCH(p,vl,c,e1,e2)) = 
  98.               (case (g e1, g e2)
  99.                         of ((false, e1'), (true, e2')) =>
  100.                 (true, BRANCH(opp p, vl,c,e2',e1'))
  101.                          | ((c1, e1'), (c2, e2')) =>
  102.                 (c1 orelse c2, BRANCH(p, vl,c,e1',e2')))
  103.               | g (e as APP(LABEL w, _)) = (sccnum w = n, e)
  104.               | g e = (false, e)
  105.           in (f, vl, #2(g body))
  106.          end
  107.  in map rewrite funs
  108. end
  109.  
  110. end
  111.  
  112.  
  113.     
  114.  
  115.  
  116.